home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpinline.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  21.9 KB  |  582 lines
  1. ;;; CMPINLINE  Open coding optimizer.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. ;;; Pass 1 generates the internal form
  25. ;;;    ( id  info-object . rest )
  26. ;;; for each form encountered.
  27.  
  28.  (defstruct info
  29.   (changed-vars nil)    ;;; List of var-objects changed by the form.
  30.   (referred-vars nil)    ;;; List of var-objects referred in the form.
  31.   (type t)        ;;; Type of the form.
  32.   (sp-change nil)    ;;; Whether execution of the form may change
  33.             ;;; the value of a special variable *VS*.
  34.   (volatile nil)    ;;; whether there is a possible setjmp
  35.   )
  36.  
  37. (defvar *info* (make-info))
  38.  
  39. (defun add-info (to-info from-info)
  40.   (setf (info-changed-vars to-info)
  41.         (append (info-changed-vars from-info)
  42.                 (info-changed-vars to-info)))
  43.   (setf (info-referred-vars to-info)
  44.         (append (info-referred-vars from-info)
  45.                 (info-referred-vars to-info)))
  46.   (when (info-sp-change from-info)
  47.         (setf (info-sp-change to-info) t))
  48.   )
  49.  
  50. (defun args-info-changed-vars (var forms)
  51.   (case (var-kind var)
  52.         ((LEXICAL FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)
  53.          (dolist** (form forms)
  54.            (when (member var (info-changed-vars (cadr form)))
  55.                  (return-from args-info-changed-vars t))))
  56.         (REPLACED nil)
  57.         (t (dolist** (form forms nil)
  58.              (when (or (member var (info-changed-vars (cadr form)))
  59.                        (info-sp-change (cadr form)))
  60.                    (return-from args-info-changed-vars t)))))
  61.   )
  62.  
  63. (defun args-info-referred-vars (var forms)
  64.   (case (var-kind var)
  65.         ((LEXICAL REPLACED FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)
  66.          (dolist** (form forms nil)
  67.            (when (member var (info-referred-vars (cadr form)))
  68.                  (return-from args-info-referred-vars t))))
  69.         (t (dolist** (form forms nil)
  70.              (when (or (member var (info-referred-vars (cadr form)))
  71.                        (info-sp-change (cadr form)))
  72.                    (return-from args-info-referred-vars t))))
  73.         ))
  74.  
  75. ;;; Valid property names for open coded functions are:
  76. ;;;  INLINE
  77. ;;;  INLINE-SAFE    safe-compile only
  78. ;;;  INLINE-UNSAFE    non-safe-compile only
  79. ;;;
  80. ;;; Each property is a list of 'inline-info's, where each inline-info is:
  81. ;;; ( types { type | boolean } side-effect new-object { string | function } ).
  82. ;;;
  83. ;;; For each open-codable function, open coding will occur only if there exits
  84. ;;; an appropriate property with the argument types equal to 'types' and with
  85. ;;; the return-type equal to 'type'.  The third element
  86. ;;; is T if and only if side effects may occur by the call of the function.
  87. ;;; Even if *VALUE-TO-GO* is TRASH, open code for such a function with side
  88. ;;; effects must be included in the compiled code.
  89. ;;; The forth element is T if and only if the result value is a new Lisp
  90. ;;; object, i.e., it must be explicitly protected against GBC.
  91.  
  92. (defvar *inline-functions* nil)
  93. (defvar *inline-blocks* 0)
  94. ;;; *inline-functions* holds:
  95. ;;;    (...( function-name . inline-info )...)
  96. ;;;
  97. ;;; *inline-blocks* holds the number of temporary cvars used to save
  98. ;;; intermediate results during evaluation of inlined function calls.
  99. ;;; This variable is used to close up blocks introduced to declare static
  100. ;;; c variables.
  101.  
  102. (defvar *special-types* '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT integer))
  103.  
  104. (defun inc-inline-blocks()
  105.   (cond ((consp *inline-blocks*)
  106.      (incf (car *inline-blocks*)))
  107.     (t (incf *inline-blocks*))))
  108.  
  109. (defun inline-args (forms types &optional fun &aux (locs nil) ii)
  110.   (do ((forms forms (cdr forms))
  111.        (types types (cdr types)))
  112.       ((endp forms) (reverse locs))
  113.       (declare (object forms types))
  114.       (let ((form (car forms))
  115.             (type (car types)))
  116.         (declare (object form type))
  117.         (case (car form)
  118.               (LOCATION (push (coerce-loc (caddr form) type) locs))
  119.               (VAR
  120.                (cond ((args-info-changed-vars (caaddr form) (cdr forms))
  121.                       (cond ((and (member (var-kind (caaddr form))
  122.                                          *special-types*)
  123.                                   (eq type (var-kind (caaddr form))))
  124.                              (let ((cvar (next-cvar)))
  125.                                (wt-nl "{" (rep-type type) "V" cvar "= V"
  126.                                       (var-loc (caaddr form)) ";")
  127.                                (push (list 'cvar cvar 'inline-args) locs)
  128.                                (inc-inline-blocks)))
  129.                             (t 
  130.                              (let ((temp (wt-c-push)))
  131.                                (wt-nl temp "= ")
  132.                                (wt-var (caaddr form) (cadr (caddr form)))
  133.                                (wt ";")
  134.                                (push (coerce-loc temp type) locs)))))
  135.                      ((and (member (var-kind (caaddr form))
  136.                                    '(FIXNUM LONG-FLOAT SHORT-FLOAT INTEGER))
  137.                            (not (eq type (var-kind (caaddr form)))))
  138.               (let ((temp (cs-push type)))
  139.             (wt-nl "V" temp " = "
  140.                    (coerce-loc (cons 'var (caddr form)) type) ";")
  141.             (push (list 'cvar temp) locs))
  142.               )
  143.                      (t (push (coerce-loc (cons 'VAR (caddr form)) type)
  144.                               locs))))
  145.               (CALL-GLOBAL
  146.                (if (let ((fname (caddr form)))
  147.              (and (inline-possible fname)
  148.               (setq ii (get-inline-info
  149.                     fname (cadddr form)
  150.                     (info-type (cadr form))))
  151.               (progn  (save-avma ii) t)))
  152.                    (let ((loc (get-inline-loc ii (cadddr form))))
  153.                         (cond
  154.                          ((or (and (flag-p (caddr ii) ans)(not *c-gc*))
  155.                         ; returns new object
  156.                               (and (member (cadr ii)
  157.                                            '(FIXNUM LONG-FLOAT SHORT-FLOAT))
  158.                                    (not (eq type (cadr ii)))))
  159.               (let ((temp (cs-push type)))
  160.                 (wt-nl "V" temp " = " (coerce-loc loc type) ";")
  161.                 (push (list 'cvar temp) locs))
  162.              )
  163.                          ((or (need-to-protect (cdr forms) (cdr types))
  164.                   ;;if either new form or side effect,
  165.                   ;;we don't want double evaluation
  166.                   (and (flag-p (caddr ii) allocates-new-storage)
  167.                    (or (null fun)
  168.                        ;; Any fun such as list,list* which
  169.                        ;; does not cause side effects or
  170.                        ;; do double eval (ie not "@..")
  171.                        ;; could go here.
  172.                        (not
  173.                      (si::memq
  174.                        fun '(list-inline list*-inline)))))
  175.                   (flag-p (caddr ii) is)
  176.                               (and (flag-p (caddr ii) set) ; side-effectp
  177.                                    (not (null (cdr forms)))))
  178.               (let (cvar)
  179.                 (cond
  180.                   ((eq type t)
  181.                    (setq cvar (cs-push))
  182.                    (wt-nl "V" cvar "= ")
  183.                    (wt-loc loc))
  184.                   (t (setq cvar (next-cvar))
  185.                  (wt-nl "{" (rep-type type) "V" cvar "= ")
  186.                  (case type
  187.                    (fixnum (wt-fixnum-loc loc))
  188.                    (integer (wt-integer-loc loc 'inline-args))
  189.                    (character (wt-character-loc loc))
  190.                    (long-float (wt-long-float-loc loc))
  191.                    (short-float (wt-short-float-loc loc))
  192.                    (otherwise (wt-loc loc)))
  193.                  (inc-inline-blocks)))
  194.                 (wt ";")
  195.                             (push (list 'cvar cvar 'inline-args) locs)
  196.                             ))
  197.                          (t (push (coerce-loc loc type) locs))))
  198.                    (let ((temp (if *c-gc* (list 'cvar (cs-push)) (list 'vs (vs-push)))))
  199.                         (let ((*value-to-go* temp)) (c2expr* form))
  200.                         (push (coerce-loc temp type) locs))))
  201.               (structure-ref
  202.                (push (coerce-loc-structure-ref (cdr form) type)
  203.                      locs))
  204.               (SETQ
  205.                (let ((vref (caddr form))
  206.                      (form1 (cadddr form)))
  207.                  (let ((*value-to-go* (cons 'var vref))) (c2expr* form1))
  208.                  (cond ((eq (car form1) 'LOCATION)
  209.                         (push (coerce-loc (caddr form1) type) locs))
  210.                        (t
  211.              (setq forms (list* form
  212.                                              (list 'VAR (cadr form) vref)
  213.                                              (cdr forms)))
  214.              ;; want (setq types (list* type type (cdr  types)))
  215.              ;; but type is first of types
  216.                           (setq types (list* type  types))))))
  217.               (t (let
  218.              ((temp
  219.                (cond (*c-gc*
  220.                   (cond ((eq type t)
  221.                      (list 'cvar (cs-push)))
  222.                     (t (push (cons type (next-cvar)) *c-vars*)
  223.                        (list 'var
  224.                          (make-var
  225.                           :type type
  226.                           :kind
  227.                           (if (member type
  228.                               *special-types*)
  229.                           type 'object)
  230.                                :loc (cdar *c-vars*))
  231.                          nil
  232.                          ))))
  233.                  (t  (list 'vs (vs-push))))))
  234.            (let ((*value-to-go* temp))
  235.              (c2expr* form)
  236.              (push (coerce-loc temp type) locs)))))))
  237.   )
  238.  
  239. (defun coerce-loc (loc type)
  240.   (case type
  241.         (fixnum (list 'FIXNUM-LOC loc))
  242.     (integer (list 'integer-loc loc ))
  243.         (character (list 'CHARACTER-LOC loc))
  244.         (long-float (list 'LONG-FLOAT-LOC loc))
  245.         (short-float (list 'SHORT-FLOAT-LOC loc))
  246.         (t loc)))
  247.  
  248. (defun get-inline-loc (ii args &aux (fun (car (cdddr ii))) locs)
  249.   ;;; Those functions that use GET-INLINE-LOC must rebind the variable *VS*.
  250.  (setq locs (inline-args args (car ii) fun))
  251.   (when (and (stringp fun) (char= (char (the string fun) 0) #\@))
  252.     (let ((i 1) (saves nil))
  253.          (declare (fixnum i))
  254.       (do ((char (char (the string fun) i)
  255.                  (char (the string fun) i)))
  256.           ((char= char #\;) (incf i))
  257.           (declare (character char))
  258.           (push (the fixnum (- (char-code char) #.(char-code #\0))) saves)
  259.           (incf i))
  260.       (do ((l locs (cdr l))
  261.            (n 0 (1+ n))
  262.            (locs1 nil))
  263.           ((endp l) (setq locs (reverse locs1)))
  264.           (declare (fixnum n) (object l))
  265.           (if (member n saves)
  266.               (let* ((loc1 (car l)) (loc loc1) (coersion nil))
  267.                     (declare (object loc loc1))
  268.                 (when (and (consp loc1)
  269.                            (member (car loc1)
  270.                                    '(FIXNUM-LOC integer-loc CHARACTER-LOC
  271.                                      LONG-FLOAT-LOC SHORT-FLOAT-LOC)))
  272.                       (setq coersion (car loc1))
  273.                       (setq loc (cadr loc1))  ; remove coersion
  274.                       )
  275.                 (cond
  276.                  ((and (consp loc)
  277.                (or
  278.              (member (car loc) 
  279.                                     '(INLINE INLINE-COND))
  280.              (and      (member (car loc)
  281.                      '(
  282.                        INLINE-FIXNUM inline-integer
  283.                        INLINE-CHARACTER INLINE-LONG-FLOAT
  284.                        INLINE-SHORT-FLOAT))
  285.                  (or (flag-p (cadr loc) allocates-new-storage)
  286.                      (flag-p (cadr loc) side-effect-p))
  287.                                 )))
  288.                   (wt-nl "{")
  289.                   (inc-inline-blocks)
  290.                   (let ((cvar (next-cvar)))
  291.                     (push (list 'CVAR cvar) locs1)
  292.                     (case coersion
  293.                      ((nil) (wt "object V" cvar "= ") (wt-loc loc1))
  294.                      (FIXNUM-LOC (wt "int V" cvar "= ") (wt-fixnum-loc loc))
  295.              (integer-loc (wt "GEN V" cvar "= ") (wt-integer-loc loc
  296.                                      'get-inline-locs))
  297.                      (CHARACTER-LOC
  298.                       (wt "unsigned char V" cvar "= ") (wt-character-loc loc))
  299.                      (LONG-FLOAT-LOC
  300.                       (wt "double V" cvar "= ") (wt-long-float-loc loc))
  301.                      (SHORT-FLOAT-LOC
  302.                       (wt "float V" cvar "= ") (wt-short-float-loc loc))
  303.                      (t (baboon))))
  304.                   (wt ";")
  305.                   )
  306.                  (t (push loc1 locs1))))
  307.               (push (car l) locs1)))))
  308.   (list (inline-type (cadr ii))
  309.         (caddr ii)
  310.         fun
  311.         locs)
  312.   )
  313. (defvar *inline-types*
  314.   '((boolean . INLINE-COND)
  315.     (fixnum . INLINE-FIXNUM)
  316.     (character . INLINE-CHARACTER)
  317.     (long-float . INLINE-LONG-FLOAT)
  318.     (short-float . INLINE-SHORT-FLOAT)
  319.     (integer . INLINE-INTEGER)
  320.     (t . INLINE)))
  321.  
  322. (defun inline-type (type)
  323.   (or (cdr (assoc type *inline-types*)) 'inline))
  324.  
  325. (defun get-inline-info (fname args return-type &aux x ii)
  326.   (and  (fast-link-proclaimed-type-p fname args)
  327.         (add-fast-link fname return-type args))
  328.   (setq args (mapcar #'(lambda (form) (info-type (cadr form))) args))
  329.   (when (if *safe-compile*
  330.             (setq x (get fname 'inline-safe))
  331.             (setq x (get fname 'inline-unsafe)))
  332.         (dolist** (y x nil)
  333.           (when (setq ii (inline-type-matches y args return-type))
  334.                 (return-from get-inline-info ii))))
  335.   (when (setq x (get fname 'inline-always))
  336.         (dolist** (y x)
  337.           (when (setq ii (inline-type-matches y args return-type))
  338.                 (return-from get-inline-info ii))))
  339.   (dolist* (x *inline-functions*)
  340.     (when (and (eq (car x) fname)
  341.            (setq ii (inline-type-matches (cdr x) args return-type)))
  342.                   (return-from get-inline-info ii)))
  343.   ;; ( n . string , function ) or string , function
  344.   
  345.   (when (and (setq x (get fname 'vfun))
  346.          (if (and (consp x) (typep (car x) 'fixnum))
  347.          (prog1 (>= (length args)  (car x)) (setq x (cdr x)))
  348.            t))
  349.     (return-from get-inline-info
  350.              (list (make-list (length args) :initial-element t)
  351.                t (flags allocates-new-storage side-effect-p)
  352.                #'(lambda (&rest l)
  353.                    (wt "(VFUN_NARGS="(length l) ",")
  354.                    (wt-inline-loc x l)
  355.                    (wt ")")))))
  356.   nil
  357.   )
  358.  
  359. (defun inline-type-matches (inline-info arg-types return-type
  360.                                         &aux (rts nil))
  361.   (if (not (typep (third inline-info) 'fixnum))
  362.       (fix-opt inline-info))
  363.   (if (and (let ((types (car inline-info)))
  364.                 (declare (object types))
  365.                 (dolist** (arg-type arg-types (or (equal types '(*))
  366.                           (endp types)))
  367.                     (when (endp types) (return nil))
  368.           (cond ((equal types '(*))
  369.              (setq types '(t *))))
  370.                   (cond ((eq (car types) 'fixnum-float)
  371.                          (cond ((type>= 'fixnum arg-type)
  372.                                 (push 'fixnum rts))
  373.                                ((type>= 'long-float arg-type)
  374.                                 (push 'long-float rts))
  375.                                ((type>= 'short-float arg-type)
  376.                                 (push 'short-float rts))
  377.                                (t (return nil))))
  378.                         ((type>= (car types) arg-type)
  379.                          (push (car types) rts))
  380.                         (t (return nil)))
  381.                   (pop types)))
  382.        (type>= (cadr inline-info) return-type))
  383.        (cons (reverse rts) (cdr inline-info))
  384.       nil)
  385.   )
  386.  
  387. (defun need-to-protect (forms types &aux ii)
  388.   (do ((forms forms (cdr forms))
  389.        (types types (cdr types)))
  390.       ((endp forms) nil)
  391.       (declare (object forms types))
  392.       (let ((form (car forms)))
  393.         (declare (object form))
  394.         (case (car form)
  395.               (LOCATION)
  396.               (VAR
  397.                (when (or (args-info-changed-vars (caaddr form) (cdr forms))
  398.                          (and (member (var-kind (caaddr form))
  399.                                       '(FIXNUM LONG-FLOAT SHORT-FLOAT))
  400.                               (not (eq (car types)
  401.                                        (var-kind (caaddr form))))))
  402.                      (return t)))
  403.               (CALL-GLOBAL
  404.                (let ((fname (caddr form)))
  405.                     (declare (object fname))
  406.                     (when
  407.                      (or (not (inline-possible fname))
  408.                          (null (setq ii (get-inline-info
  409.                                          fname (cadddr form)
  410.                                          (info-type (cadr form)))))
  411.              (flag-p (caddr ii) allocates-new-storage)
  412.              (flag-p (caddr ii) set)
  413.              (flag-p (caddr ii) is)
  414.                          (and (member (cadr ii)
  415.                                       '(fixnum long-float short-float))
  416.                               (not (eq (car types) (cadr ii))))
  417.                          (need-to-protect (cadddr form) (car ii)))
  418.                      (return t))))
  419.               (structure-ref
  420.                (when (need-to-protect (list (caddr form)) '(t))
  421.                      (return t)))
  422.               (t (return t)))))
  423.   )
  424.  
  425. (defun wt-c-push ()
  426.   (cond (*c-gc* (inc-inline-blocks)
  427.         (let ((tem (next-cvar)))
  428.           (wt "{" *volatile* "object V" tem ";")
  429.           (list 'cvar tem)))
  430.     (t (list 'VS (vs-push)))))
  431.  
  432. (defun close-inline-blocks ( &aux (bl *inline-blocks*))
  433.   (when (consp bl)
  434.     (if (eql (cdr bl) 'restore-avma) (wt "restore_avma;"))
  435.     (setq bl (car bl)))
  436.   (dotimes** (i bl) (wt "}")))
  437.  
  438. (si:putprop 'inline 'wt-inline 'wt-loc)
  439. (si:putprop 'inline-cond 'wt-inline-cond 'wt-loc)
  440. (si:putprop 'inline-fixnum 'wt-inline-fixnum 'wt-loc)
  441. (si:putprop 'inline-integer 'wt-inline-integer 'wt-loc)
  442. (si:putprop 'inline-character 'wt-inline-character 'wt-loc)
  443. (si:putprop 'inline-long-float 'wt-inline-long-float 'wt-loc)
  444. (si:putprop 'inline-short-float 'wt-inline-short-float 'wt-loc)
  445.  
  446. (defun wt-inline-loc (fun locs &aux (i 0) (max -1))
  447.        (declare (fixnum i max))
  448.   (cond ((stringp fun)
  449.          (when (char= (char (the string fun) 0) #\@)
  450.            (setq i 1)
  451.            (do ()
  452.                ((char= (char (the string fun) i) #\;) (incf i))
  453.                (incf i)))
  454.          (do ((size (length (the string fun))))
  455.              ((>= i size))
  456.              (declare (fixnum size ))
  457.              (let ((char (char (the string fun) i)))
  458.                   (declare (character char))
  459.                   (cond ((char= char #\#)
  460.              (let ((ch  (char (the string fun)
  461.                                                         (the fixnum (1+ i))))
  462.                    (n 0))
  463.                (cond ((eql ch #\*)
  464.                   (if (and (>= max 0)
  465.                        (< (1+ max) (length locs)))
  466.                       (wt ","))
  467.                   (do ((v  (nthcdr (1+ max) locs) (cdr v)))
  468.                       ((null v))
  469.                       (wt-loc (car v))
  470.                       (if (cdr v) (wt ","))))
  471.                  ((digit-char-p ch 10)
  472.                   (setq n (- (char-code ch)
  473.                          (char-code #\0)))
  474.                   (when (and
  475.                      (> (length fun) (+ i 2))
  476.                      (setq ch (char (the string fun)
  477.                             (+ i 2)))
  478.                      (digit-char-p ch))
  479.                     (setq n (+ (* n 10)
  480.                            (- (char-code ch)
  481.                               (char-code #\0))))
  482.                     (incf i))
  483.                   (cond ((>= n max) (setq  max n)))
  484.                   (wt-loc (nth n locs)))))
  485.                          (incf i 2))
  486.                         (t
  487.                          (princ char *compiler-output1*)
  488.                          (incf i)))))
  489.          )
  490.         (t (apply fun locs))))
  491.  
  492. (defun wt-inline (side-effectp fun locs)
  493.   (declare (ignore side-effectp))
  494.   (wt-inline-loc fun locs))
  495.  
  496. (defun wt-inline-cond (side-effectp fun locs)
  497.   (declare (ignore side-effectp))
  498.   (wt "(") (wt-inline-loc fun locs) (wt "?Ct:Cnil)"))
  499.  
  500. (defun wt-inline-fixnum (side-effectp fun locs)
  501.   (declare (ignore side-effectp))
  502.   (when (zerop *space*) (wt "CMP"))
  503.   (wt "make_fixnum(") (wt-inline-loc fun locs) (wt ")"))
  504.  
  505. (defun wt-inline-integer (side-effectp fun locs)
  506.   (declare (ignore side-effectp))
  507.   (wt "make_integer(") (wt-inline-loc fun locs) (wt ")"))
  508.  
  509. (defun wt-inline-character (side-effectp fun locs)
  510.   (declare (ignore side-effectp))
  511.   (wt "code_char(") (wt-inline-loc fun locs) (wt ")"))
  512.  
  513. (defun wt-inline-long-float (side-effectp fun locs)
  514.   (declare (ignore side-effectp))
  515.   (wt "make_longfloat(") (wt-inline-loc fun locs) (wt ")"))
  516.  
  517. (defun wt-inline-short-float (side-effectp fun locs)
  518.   (declare (ignore side-effectp))
  519.   (wt "make_shortfloat(") (wt-inline-loc fun locs) (wt ")"))
  520.  
  521. (defun args-cause-side-effect (forms &aux ii)
  522.   (dolist** (form forms nil)
  523.     (case (car form)
  524.           ((LOCATION VAR structure-ref))
  525.           (CALL-GLOBAL
  526.            (let ((fname (caddr form)))
  527.                 (declare (object fname))
  528.                 (unless (and (inline-possible fname)
  529.                              (setq ii (get-inline-info
  530.                                        fname (cadddr form)
  531.                                        (info-type (cadr form))))
  532.                  (progn (fix-opt ii)
  533.                     (not (flag-p (caddr ii) side-effect-p)))
  534.                                   )
  535.                         (return t))))
  536.           (otherwise (return t)))))
  537.  
  538. ;;; Borrowed from CMPOPT.LSP
  539.  
  540. (defun list-inline (&rest x &aux tem (n (length x)))
  541.    (cond ((setq tem
  542.         (and (consp *value-to-go*)
  543.              (eq (car *value-to-go*) 'var)
  544.              (eq (var-type (second *value-to-go*)) :dynamic-extent)))
  545.       (wt "(ALLOCA_CONS(" n "),ON_STACK_LIST(" n))
  546.      (t (wt "list(" (length x))))
  547.    (dolist (loc x) (wt #\, loc))
  548.    (wt #\))
  549.    (if tem (wt #\)))
  550. )
  551.  
  552.  
  553. (defun list*-inline (&rest x)
  554.   (case (length x)
  555.         (1 (wt (car x)))
  556.         (2 (wt "make_cons(" (car x) "," (cadr x) ")"))
  557.         (otherwise
  558.          (wt "listA(" (length x)) (dolist (loc x) (wt #\, loc)) (wt #\)))))
  559.  
  560. ;;; Borrowed from LFUN_LIST.LSP
  561.  
  562. (defun defsysfun (fname cname-string arg-types return-type
  563.                         never-change-special-var-p predicate)
  564.   ;;; The value NIL for each parameter except for fname means "not known".
  565.   (when cname-string (si:putprop fname cname-string 'Lfun))
  566.   (when arg-types
  567.         (si:putprop fname (mapcar #'(lambda (x)
  568.                       (if (eq x '*) '* (type-filter x)))
  569.                       arg-types) 'arg-types))
  570.  
  571.   (when return-type
  572.     (let ((rt (function-return-type (if (atom return-type)
  573.                         (list return-type)
  574.                       return-type))))
  575.       (or  (consp rt) (setq rt (list rt)))
  576.     (si:putprop fname (if (null (cdr rt)) (car rt) (cons 'values rt))
  577.                 'return-type)))
  578.   (when never-change-special-var-p (si:putprop fname t 'no-sp-change))
  579.   (when predicate (si:putprop fname t 'predicate))
  580.   )
  581.  
  582.